(define (ufcd:find-congruent-division prog descr)
  (define meta-confs #f)
  (define meta-confs-modified? #f)
  (define (collect-mc-prog!)
    (for-each
      (lambda (fundef)
        (let ((body (cadddr fundef))
              (pars (cadr fundef))
              (fname (car fundef)))
          (let ((%%1 (assq fname meta-confs)))
            (let ((res (cddr %%1)) (args (cadr %%1)))
              (update-mc!
                fname
                args
                (abstract-eval body pars args))
              (collect-mc! body pars args)))))
      prog))
  (define (collect-mc! exp vn vv)
    (cond ((symbol? exp) #f)
          ((equal? (car exp) 'quote)
           (let ((exp (cadr exp))) #f))
          ((let ((fname_exp* (cdr exp)) (call? (car exp)))
             (memq call? '(call rcall)))
           (let ((fname_exp* (cdr exp)) (call? (car exp)))
             (let ((exp* (cdr fname_exp*))
                   (fname (car fname_exp*)))
               (let ((%%2 (collect-mc*! exp* vn vv)))
                 (let ((%%3 (abstract-eval* exp* vn vv)))
                   (let ((args %%3))
                     (let ((%%4 (lub-list args)))
                       (let ((res %%4)) (update-mc! fname args res)))))))))
          ((equal? (car exp) 'xcall)
           (let ((exp* (cddr exp)) (fname (cadr exp)))
             (collect-mc*! exp* vn vv)))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             (collect-mc*! exp* vn vv)))))
  (define (collect-mc*! exp* vn vv)
    (for-each
      (lambda (exp) (collect-mc! exp vn vv))
      exp*))
  (define (abstract-eval exp vn vv)
    (cond ((symbol? exp) (lookup-variable exp vn vv))
          ((equal? (car exp) 'quote)
           (let ((exp (cadr exp))) 's))
          ((equal? (car exp) 'generalize)
           (let ((exp (cadr exp))) 'd))
          ((let ((fname_exp* (cdr exp)) (call? (car exp)))
             (memq call? '(call rcall)))
           (let ((fname_exp* (cdr exp)) (call? (car exp)))
             (let ((exp* (cdr fname_exp*))
                   (fname (car fname_exp*)))
               (let ((%%5 (assq fname meta-confs)))
                 (let ((fres (cddr %%5)) (fargs (cadr %%5))) fres)))))
          ((equal? (car exp) 'xcall)
           (let ((exp* (cddr exp)) (fname (cadr exp)))
             (lub-list (abstract-eval* exp* vn vv))))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             (lub-list (abstract-eval* exp* vn vv))))))
  (define (abstract-eval* exp* vn vv)
    (map (lambda (exp) (abstract-eval exp vn vv))
         exp*))
  (define (lub ind1 ind2)
    (if (eq? ind1 'd) 'd ind2))
  (define (lub-list ind*)
    (if (memq 'd ind*) 'd 's))
  (define (initial-meta-confs prog)
    (map (lambda (fundef)
           (let ((fpars (cadr fundef)) (fname (car fundef)))
             `(,fname ,(map (lambda (par) 's) fpars) . s)))
         prog))
  (define (update-mc! fname args res)
    (let ((%%6 (assq fname meta-confs)))
      (let ((fdescr %%6))
        (let ((res1 (cddr fdescr)) (args1 (cadr fdescr)))
          (let ((%%7 (map lub args args1)))
            (let ((lub-args %%7))
              (let ((%%8 (lub res res1)))
                (let ((lub-res %%8))
                  (if (or (not (equal? lub-args args1))
                          (not (equal? lub-res res1)))
                    (begin
                      (set-cdr! fdescr `(,lub-args unquote lub-res))
                      (set! meta-confs-modified? #t)))))))))))
  (define (lookup-variable vname vn vv)
    (if (and (null? vn) (null? vv))
      (error "Undefined variable: " vname)
      (let ((vrest (cdr vv))
            (vv (car vv))
            (nrest (cdr vn))
            (vn (car vn)))
        (if (eq? vname vn)
          vv
          (lookup-variable vname nrest vrest)))))
  (let ((prog-rest (cdr prog)) (fname (caar prog)))
    (set! meta-confs
      `((,fname ,descr unquote (lub-list descr))
        unquote
        (initial-meta-confs prog-rest))))
  (let recalc-mc! ()
    (display "*")
    (set! meta-confs-modified? #f)
    (collect-mc-prog!)
    (if meta-confs-modified? (recalc-mc!) meta-confs)))

